home *** CD-ROM | disk | FTP | other *** search
/ TeX 1995 July / TeX CD-ROM July 1995 (Disc 1)(Walnut Creek)(1995).ISO / web / reduce / rweb / appl / source / tools.red < prev   
Encoding:
Text File  |  1992-02-05  |  12.4 KB  |  447 lines
  1. %2:%
  2. %line 64 "tools.web"
  3. symbolic$
  4. write"Algebraic operator tools for REDUCE 3.4, $Revision: 1.4 $"$terpri()$
  5. algebraic$
  6.  
  7. %:2%%7:%
  8. %line 129 "tools.web"
  9. lisp procedure get_first_kernel(form,oplist);
  10. gfk(form,if null oplist then oplist else if atom
  11. oplist then list oplist else if
  12. car oplist= 'list then cdr oplist else oplist,nil)$
  13.  
  14. lisp procedure gfk(form,oplist,l);
  15. if l or domainp form then l
  16. else gfk(red form,oplist,
  17. gfk(lc form,oplist,
  18. if not atom x and member(car x,oplist)
  19. then x else l))
  20. where x=mvar form$
  21.  
  22. %:7%%8:%
  23. %line 146 "tools.web"
  24.  
  25. %line 147 "tools.web"
  26. lisp procedure get_all_kernels(form,oplist);
  27. gak(form,if null oplist then oplist else if atom
  28. oplist then list oplist else if
  29. car oplist= 'list then cdr oplist else oplist,nil)$
  30.  
  31. lisp procedure gak(form,oplist,l);
  32. if domainp form
  33. then l
  34. else gak(red form,oplist,
  35. gak(lc form,oplist,
  36. if not atom x and member(car x,oplist)and not member(x,l)
  37. then l:=aconc(l,x)else l))
  38. where x=mvar form$
  39.  
  40. %:8%%9:%
  41. %line 163 "tools.web"
  42.  
  43. %line 164 "tools.web"
  44. lisp procedure get_recursive_kernels(form,oplist);
  45. grk(form,if null oplist then oplist else if atom
  46. oplist then list oplist else if
  47. car oplist= 'list then cdr oplist else oplist,nil)$
  48.  
  49. lisp procedure grk(form,oplist,l);
  50. if domainp form
  51. then l else grk(red form,oplist,
  52. grk(lc form,oplist,
  53. %10:%
  54. %line 177 "tools.web"
  55.  
  56. %line 178 "tools.web"
  57. if not atom x
  58. then begin scalar y;
  59. for each arg in cdr x do
  60. if(y:=simp arg)neq 0 then
  61. l:=grk(numr y,oplist,l);
  62. return if member(car x,oplist)and not member(x,l)
  63. then x . l else l end
  64. else l
  65.  
  66. %:10%
  67. %line 171 "tools.web"
  68. ))
  69. where x=mvar form$
  70.  
  71. %:9%%14:%
  72. %line 280 "tools.web"
  73.  
  74. %line 281 "tools.web"
  75. lisp procedure split_f(form,oplist,fact,kc_list);
  76. if null form then kc_list
  77. else if domainp form then
  78. addf(multf(fact,form),
  79. car kc_list) . cdr kc_list
  80. else if not atom mvar form and member(car mvar form,oplist)then
  81. if not ldeg form=1 or get_first_kernel(lc form,oplist)then
  82.  
  83. msgpri("SPLIT_F: expression not linear w.r.t.",
  84.  'list . oplist,nil,nil,t)
  85. else split_f(red form,oplist,fact,
  86. update_kc_list(kc_list,mvar form,multf(fact,lc form)))
  87. else split_f(red form,oplist,fact,
  88. split_f(lc form,oplist,
  89. multf(fact,!*p2f lpow form),kc_list))$
  90.  
  91. %:14%%15:%
  92. %line 300 "tools.web"
  93.  
  94. %line 301 "tools.web"
  95. lisp procedure split_form(form,oplist);
  96. split_f(form,oplist,1,nil . nil)$
  97.  
  98. %:15%%16:%
  99. %line 309 "tools.web"
  100. lisp procedure list_assoc(car_exprn,a_list);
  101. %line 310 "tools.web"
  102. if null a_list then a_list else if caar a_list=car_exprn then a_list
  103. else list_assoc(car_exprn,cdr a_list)$
  104.  
  105. %:16%%17:%
  106. %line 322 "tools.web"
  107. lisp procedure update_kc_list(kc_list,kernel,coefficient);
  108. %line 323 "tools.web"
  109. (if rest_list then <<rplaca(rest_list,caar rest_list . addf(cdar
  110. rest_list,coefficient));kc_list>> else
  111. car kc_list . (kernel . coefficient) . cdr kc_list)
  112. where rest_list=list_assoc(kernel,cdr kc_list)$
  113.  
  114. %:17%%18:%
  115. %line 347 "tools.web"
  116.  
  117. %line 348 "tools.web"
  118. put( 'operator_coeff, 'psopfn, 'operator_coeff_1)$
  119.  
  120. lisp procedure operator_coeff_1 u;
  121. if length u neq 2 then rederr("OPERATOR_COEFF: wrong number of arguments")
  122. else operator_coeff(car u,reval cadr u)$
  123.  
  124. %:18%%19:%
  125. %line 370 "tools.web"
  126.  
  127. %line 371 "tools.web"
  128. lisp procedure operator_coeff(exprn,oplist);
  129. begin scalar numr_ex,denr_ex,kc_list;
  130. oplist:=if null oplist then oplist else if atom
  131. oplist then list oplist else if
  132. car oplist= 'list then cdr oplist else oplist;
  133. exprn:=simp!* exprn;numr_ex:=numr exprn;denr_ex:=denr exprn;
  134. kc_list:=split_form(numr_ex,oplist);
  135. return 'list . !*ff2a(car kc_list,denr_ex) . 
  136. for each kc_pair in cdr kc_list collect
  137. list( 'list,car kc_pair,!*ff2a(cdr kc_pair,denr_ex));
  138. end$
  139.  
  140. %:19%%20:%
  141. %line 402 "tools.web"
  142.  
  143. %line 403 "tools.web"
  144. lisp procedure dump_operators(form,oplist,fact);
  145. if null form then nil
  146. else if domainp form then multf(fact,form)
  147. else if not atom mvar form and member(car mvar form,oplist)then
  148. dump_operators(red form,oplist,fact)
  149. else
  150. addf(dump_operators(red form,oplist,fact),
  151. dump_operators(lc form,oplist,multf(fact,!*p2f lpow form)))$
  152.  
  153. %:20%%21:%
  154. %line 413 "tools.web"
  155.  
  156. %line 414 "tools.web"
  157. put( 'independent_part, 'psopfn, 'independent_part_1)$
  158.  
  159. lisp procedure independent_part_1 u;
  160. if length u neq 2 then rederr("INDEPENDENT_PART: wrong number of arguments")
  161. else independent_part(car u,reval cadr u)$
  162.  
  163. lisp procedure independent_part(exprn,oplist);
  164. begin scalar numr_ex,denr_ex;
  165. oplist:=if null oplist then oplist else if atom
  166. oplist then list oplist else if
  167. car oplist= 'list then cdr oplist else oplist;
  168. exprn:=simp!* exprn;numr_ex:=numr exprn;denr_ex:=denr exprn;
  169. return !*ff2a(dump_operators(numr_ex,oplist,1),denr_ex);
  170. end$
  171.  
  172. %:21%%22:%
  173. %line 464 "tools.web"
  174.  
  175. lisp procedure multi_split_f(form,kernel_list,multi_power,fact,pc_list);
  176. if null form then pc_list
  177. else if domainp form then
  178. if multi_power then update_kc_list(pc_list,multi_power,multf(fact,form))
  179. else addf(multf(fact,form),car pc_list) . cdr pc_list
  180. else multi_split_f(red form,kernel_list,multi_power,fact,
  181. if member(mvar form,kernel_list)then
  182. multi_split_f(lc form,kernel_list,lpow form . multi_power,fact,pc_list)
  183. else multi_split_f(lc form,kernel_list,multi_power,
  184. multf(fact,!*p2f lpow form),pc_list))$
  185.  
  186.  
  187. %:22%%23:%
  188. %line 481 "tools.web"
  189.  
  190. lisp procedure multi_split_form(form,kernel_list);
  191. multi_split_f(form,kernel_list,nil,1,nil . nil)$
  192.  
  193. %:23%%24:%
  194. %line 496 "tools.web"
  195.  
  196. %line 497 "tools.web"
  197. put( 'multi_coeff, 'psopfn, 'multi_coeff_1)$
  198.  
  199. lisp procedure multi_coeff_1 u;
  200. if length u neq 2 then rederr("MULTI_COEFF: wrong number of arguments")
  201. else multi_coeff(car u,reval cadr u)$
  202.  
  203. %:24%%25:%
  204. %line 509 "tools.web"
  205. lisp procedure multi_coeff(exprn,kernel_list);
  206. %line 510 "tools.web"
  207. begin scalar numr_ex,denr_ex,pc_list;
  208. kernel_list:=if null kernel_list then kernel_list else if atom
  209. kernel_list then list kernel_list else if
  210. car kernel_list= 'list then cdr kernel_list else kernel_list;
  211. exprn:=simp!* exprn;
  212. numr_ex:=numr exprn;denr_ex:=denr exprn;
  213. for each generator in kernel_list do if depends(denr_ex,generator)
  214. then
  215. msgpri("MULTI_COEFF: expression is not polynomial w.r.t. ",
  216.  'list . kernel_list,nil,nil,t);
  217. pc_list:=multi_split_form(numr_ex,kernel_list);
  218. return 'list . !*ff2a(car pc_list,denr_ex) . 
  219. for each pc_pair in cdr pc_list collect
  220. list( 'list,convert_multi_power car pc_pair,!*ff2a(cdr pc_pair,denr_ex));
  221. end$
  222.  
  223. %:25%%26:%
  224. %line 529 "tools.web"
  225.  
  226. %line 530 "tools.web"
  227. lisp procedure convert_multi_power multi_power;
  228.  'times . for each power in multi_power collect
  229. if cdr power=1 then car power else list( 'expt,car power,cdr power)$
  230.  
  231. %:26%%28:%
  232. %line 588 "tools.web"
  233.  
  234. %line 589 "tools.web"
  235. lisp procedure split_arguments(arg_list,oplist,splitted_list);
  236. if null arg_list then splitted_list
  237. else split_arguments(cdr arg_list,oplist,
  238. multf(denr first_arg,car splitted_list) . 
  239. split_form(numr first_arg,oplist) . 
  240. cdr splitted_list)where first_arg=simp!* car arg_list$
  241.  
  242. %:28%%29:%
  243. %line 604 "tools.web"
  244. lisp procedure split_operator u;
  245. %line 605 "tools.web"
  246. split_arguments(cdr u,get(car u, 'oplist),1 . nil)$
  247.  
  248. %:29%%31:%
  249. %line 669 "tools.web"
  250. lisp procedure process_arg_stack(arg_stack,op_name,arg_list,fact);
  251. %line 670 "tools.web"
  252. if null arg_stack then multsq(!*f2q fact,
  253. apply1(get(op_name, 'resimp_fn),op_name . arg_list))
  254. else process_comp_list(car arg_stack,cdr arg_stack,op_name,arg_list,fact)$
  255.  
  256. %:31%%32:%
  257. %line 678 "tools.web"
  258.  
  259. %line 679 "tools.web"
  260. lisp procedure process_comp_list(comp_list,arg_stack,op_name,arg_list,fact);
  261. addsq(process_independent_part(car comp_list,arg_stack,op_name,arg_list,fact),
  262. process_components(cdr comp_list,arg_stack,op_name,arg_list,fact))$
  263.  
  264. %:32%%33:%
  265. %line 691 "tools.web"
  266. lisp procedure process_independent_part(independent_part,arg_stack,
  267. %line 692 "tools.web"
  268. op_name,arg_list,fact);
  269. if null independent_part then nil . 1
  270. else
  271. process_arg_stack(arg_stack,op_name,1 . arg_list,multf(fact,independent_part))$
  272.  
  273.  
  274. %:33%%34:%
  275. %line 701 "tools.web"
  276. lisp procedure process_components(comp_list,arg_stack,op_name,arg_list,fact);
  277. %line 702 "tools.web"
  278. if null comp_list then nil . 1
  279. else
  280. addsq(process_components(cdr comp_list,arg_stack,op_name,arg_list,fact),
  281. process_arg_stack(arg_stack,op_name,caar comp_list . arg_list,
  282. multf(fact,cdar comp_list)))$
  283.  
  284. %:34%%35:%
  285. %line 713 "tools.web"
  286. lisp procedure build_sum(op_name,arg_stack);
  287. %line 714 "tools.web"
  288. process_arg_stack(arg_stack,op_name,nil,1)$
  289.  
  290. %:35%%36:%
  291. %line 727 "tools.web"
  292. lisp procedure simp_multilinear u;
  293. %line 728 "tools.web"
  294. quotsq(build_sum(car u,cdr splitted_list),!*f2q car splitted_list)
  295. where splitted_list=split_operator u$
  296.  
  297. %:36%%38:%
  298. %line 750 "tools.web"
  299.  
  300. %line 751 "tools.web"
  301. put( 'multilinear, 'stat, 'rlis)$
  302.  
  303. lisp procedure multilinear u;
  304. for each decl in u do
  305. begin scalar op_name,resimp_fn;
  306. if length decl neq 2 and length decl neq 3 then
  307.  
  308. msgpri(nil,decl,"invalid multilinear declaration",nil,t);
  309. if not idp(op_name:=car decl)then
  310.  
  311. msgpri(nil,op_name,"invalid as operator",nil,t);
  312. put(op_name, 'oplist,if null cadr decl then cadr decl else if atom
  313. cadr decl then list cadr decl else if
  314. car cadr decl= 'list then cdr cadr decl else cadr decl);
  315. if(length decl=3 and(resimp_fn:=caddr decl))or
  316. (resimp_fn:=get(op_name, 'resimp_fn))or
  317. (resimp_fn:=get(op_name, 'simpfn))then put(op_name, 'resimp_fn,resimp_fn)
  318. else put(op_name, 'resimp_fn, 'simpiden);
  319. put(op_name, 'simpfn, 'simp_multilinear);
  320. flag(list(op_name), 'full);
  321. end$
  322.  
  323. %:38%%41:%
  324. %line 795 "tools.web"
  325.  
  326. %line 796 "tools.web"
  327. put( 'linear_solve, 'psopfn, 'linear_solve_1)$
  328.  
  329. lisp procedure linear_solve_1 u;
  330. if length u neq 2 then
  331. rederr("LINEAR_SOLVE: wrong number of arguments")
  332. else linear_solve(car u,cadr u)$
  333.  
  334. %:41%%43:%
  335. %line 845 "tools.web"
  336.  
  337. %line 846 "tools.web"
  338. lisp procedure linear_solve(exprn,kernel);
  339. begin scalar kord!*,form;
  340. kernel:=!*a2k kernel;
  341. %42:%
  342. %line 814 "tools.web"
  343.  
  344. %line 815 "tools.web"
  345. exprn:=fctrf numr simp!* exprn;
  346. exprn:=if domainp car exprn then cdr exprn else(car exprn . 1) . cdr exprn;
  347. form:=for each factor in exprn join
  348. if depends(factor,kernel)then list factor;
  349. if length form=1 then form:=numr car form else
  350.  
  351. msgpri("LINEAR_SOLVE: expression not linear with respect to",
  352. kernel,nil,nil,t)
  353.  
  354. %:42%
  355. %line 849 "tools.web"
  356. ;
  357. setkorder list kernel;
  358. form:=reorder form;
  359. if(mvar form=kernel)and(ldeg form=1)and
  360. not depends(lc form,kernel)and not depends(red form,kernel)then
  361. return !*ff2a(negf red form,lc form)
  362. else
  363. msgpri("LINEAR_SOLVE: expression not linear with respect to",
  364. kernel,nil,nil,t);
  365. end$
  366.  
  367. %:43%%44:%
  368. %line 863 "tools.web"
  369.  
  370. %line 864 "tools.web"
  371. put( 'linear_solve_and_assign, 'psopfn, 'linear_solve_and_assign_1)$
  372.  
  373. lisp procedure linear_solve_and_assign_1 u;
  374. if length u neq 2 then
  375. rederr("LINEAR_SOLVE_AND_ASSIGN: wrong number of arguments")
  376. else linear_solve_and_assign(car u,cadr u)$
  377.  
  378. lisp procedure linear_solve_and_assign(exprn,kernel);
  379. setk(kernel,linear_solve(exprn,kernel))$
  380.  
  381. %:44%%47:%
  382. %line 926 "tools.web"
  383.  
  384. %line 927 "tools.web"
  385. put( 'solvable_kernels, 'psopfn, 'solvable_kernels_1)$
  386.  
  387. lisp procedure solvable_kernels_1 u;
  388. if length u neq 3 then
  389. rederr("SOLVABLE_KERNELS: wrong number of arguments")
  390. else solvable_kernels(car u,cadr u,caddr u)$
  391.  
  392. %:47%%49:%
  393. %line 964 "tools.web"
  394.  
  395. %line 965 "tools.web"
  396. lisp procedure list_merge(element,merge_list);
  397. if member(element,merge_list)then merge_list else element . 
  398. merge_list$
  399.  
  400. %:49%%50:%
  401. %line 984 "tools.web"
  402. lisp procedure mk_kernel_list(form,k_oplist,c_oplist,forbidden,kernel_list);
  403. %line 985 "tools.web"
  404. if domainp form then kernel_list
  405. else(
  406. if not atom kernel then
  407. mk_kernel_list(red form,k_oplist,c_oplist,forbidden,
  408. mk_kernel_list(lc form,k_oplist,c_oplist,
  409. if member(car kernel,c_oplist)then t else forbidden,
  410. if member(car kernel,k_oplist)then
  411. if not forbidden and ldeg form=1 and
  412. not get_first_kernel(lc form,c_oplist)then
  413. list_merge(kernel,car kernel_list) . cdr kernel_list
  414. else
  415. car kernel_list . list_merge(kernel,cdr kernel_list)
  416. else kernel_list))
  417. else mk_kernel_list(red form,k_oplist,c_oplist,forbidden,
  418. mk_kernel_list(lc form,k_oplist,c_oplist,forbidden,kernel_list))
  419. )where kernel=mvar form$
  420.  
  421. %:50%%51:%
  422. %line 1012 "tools.web"
  423.  
  424. %line 1013 "tools.web"
  425. lisp procedure solvable_kernels(exprn,k_oplist,c_oplist);
  426. begin scalar form,kernel_list,forbidden_kernels;
  427. form:=numr simp!* exprn;
  428. k_oplist:=if null k_oplist then k_oplist else if atom
  429. k_oplist then list k_oplist else if
  430. car k_oplist= 'list then cdr k_oplist else k_oplist;
  431. c_oplist:=if null c_oplist then c_oplist else if atom
  432. c_oplist then list c_oplist else if
  433. car c_oplist= 'list then cdr c_oplist else c_oplist;
  434. kernel_list:=mk_kernel_list(form,k_oplist,c_oplist,nil,nil . nil);
  435. forbidden_kernels:=cdr kernel_list;
  436. kernel_list:=car kernel_list;
  437. for each kernel in forbidden_kernels do kernel_list:=delete(kernel,kernel_list);
  438. return 'list . kernel_list;
  439. end$
  440.  
  441. %:51%%52:%
  442. %line 1027 "tools.web"
  443. end;
  444. %line 1028 "tools.web"
  445.  
  446. %:52%
  447.